home *** CD-ROM | disk | FTP | other *** search
/ Sprite 1984 - 1993 / Sprite 1984 - 1993.iso / lib / perl / option.pl < prev    next >
Encoding:
Perl Script  |  1991-11-17  |  2.9 KB  |  144 lines
  1. #!/sprite/cmds/perl 
  2. # option.pl
  3. # Implements the Sprite "Opt" package in Perl.  See the "Opt" man page.
  4. # Example:
  5. #
  6. #    $t = 0;
  7. #    $f = 1;
  8. #    $s = "hello";
  9. #    @bar = ('t', $OPT_TRUE, *t, 'true',
  10. #        'f', $OPT_FALSE, *f, 'false');
  11. #    &Opt_Parse(*ARGV, *bar, 0);
  12. #    printf("$t $f\n");
  13. #
  14.  
  15.  
  16. $OPT_ALLOW_CLUSTERING     = 0x1;
  17. $OPT_OPTIONS_FIRST    = 0x2;
  18. $OPT_NO_SPACE        = 0x4;
  19.  
  20. $OPT_NIL = " ";
  21.  
  22. $OPT_FALSE = 0;
  23. $OPT_TRUE = 1;
  24. $OPT_INT = 2;
  25. $OPT_FLOAT = 3;
  26. $OPT_STRING = 4;
  27. $OPT_DOC = 5;
  28. $OPT_REST = 6;
  29. $OPT_FUNC = 7;
  30. $OPT_GENFUNC = 8;
  31.  
  32.  
  33. sub Opt_PrintUsage {
  34.     while($name = shift) {
  35.     $type = shift;
  36.     local(*ptr) = shift;
  37.     $doc = shift;
  38.     if ($type != $OPT_DOC) {
  39.         printf(" -$name:\t$doc\n");
  40.         if (($type == $OPT_INT) || ($type == $OPT_FLOAT) || 
  41.         ($type == $OPT_STRING)) {
  42.         printf("\t\tDefault value: \"$ptr\"\n");
  43.         }
  44.     } else {
  45.         printf("$doc\n");
  46.     }
  47.  
  48.     }
  49. }
  50.  
  51. sub PrintUsage {
  52.     local($option) = shift;
  53.     local(*argv) = shift;
  54.     &Opt_PrintUsage(@optHelp);
  55.     @argv = ();
  56. }
  57.  
  58. sub Opt_Parse {
  59.     local(*argv) = shift;
  60.     local(@optArray) = @_;
  61.     local($flags) = pop(@optArray);
  62.     local(%options, $name, %ptrs, $doeval, $type, $doc, @newargv, $rest);
  63.     local(@targv) = *argv;
  64.     local($clustered) = 0;
  65.     local($consumed) = 0;
  66.  
  67.     @optHelp = @optArray;
  68.     $types{"-help"} = $OPT_GENFUNC;
  69.     $ptrs{"-help"} = *PrintUsage;
  70.     $doc{"-help"} = "Print this message";
  71.     $types{"-?"} = $OPT_GENFUNC;
  72.     $ptrs{"-?"} = *PrintUsage;
  73.     $doc{"-?"} = "Print this message";
  74.     $reg{"-\\?"} = 1;
  75.     while($name = shift(@optArray)) {
  76.     $types{"-$name"} = shift(@optArray);
  77.     $ptrs{"-$name"} = shift(@optArray);
  78.     $doc{"-$name"} = shift(@optArray);
  79.     $reg{"-$name"} = 1;
  80.     }
  81. option:
  82.     while($name = shift(@argv)) {
  83.     $clustered = 0;
  84.     if ($name !~ /-.*/) {
  85.         push(@newargv, $name);
  86.         if ($flags & $OPT_OPTIONS_FIRST) {
  87.         push(@newargv, @argv);
  88.         last option;
  89.         } else {
  90.         next option;
  91.         }
  92.     }
  93. lookup:
  94.     while(1) {
  95.         $consumed = 0;
  96.         if (defined($types{"$name"})) {
  97.         local(*ptr) = $ptrs{"$name"};
  98.         $doeval = 1;
  99.         $type = $types{"$name"};
  100.         if ($type == $OPT_TRUE) {
  101.             $value = 1;
  102.         } elsif ($type == $OPT_FALSE) {
  103.             $value = 0;
  104.         } elsif (($type == $OPT_INT) || ($type == $OPT_FLOAT) || 
  105.             ($type == $OPT_STRING)) {
  106.             $value = shift(@argv) || die("$name needs argument\n");
  107.             $consumed = 1;
  108.         } elsif ($type == $OPT_FUNC) {
  109.             if(&ptr($name, $argv[0])) {
  110.             shift(@argv);
  111.             $consumed = 1;
  112.             }
  113.             $doeval = 0;
  114.         } elsif ($type == $OPT_GENFUNC) {
  115.             &ptr($name, *argv);
  116.             $doeval = 0;
  117.         }
  118.         if ($doeval == 1) {
  119.             $ptr = $value;
  120.         }
  121.         if (($flags & $OPT_ALLOW_CLUSTERING) && !$consumed && 
  122.             $clustered) {
  123.             $argv[0] = "-$argv[0]";
  124.         }
  125.         last lookup;
  126.         }
  127.         if ($flags & ($OPT_NO_SPACE | $OPT_ALLOW_CLUSTERING)) {
  128.         $clustered = 1;
  129.         foreach $i (keys(%reg)) {
  130.             if ($name =~ /$i(.*)/) {
  131.             unshift(argv, $1);
  132.             $name = $i;
  133.             next lookup;
  134.             }
  135.         }
  136.         }
  137.         push(@newargv, $name);
  138.         last lookup;
  139.     }
  140.     }
  141.     @argv = @newargv;
  142. }
  143.  
  144.